home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / UTILS.SEQ < prev    next >
Text File  |  1988-06-28  |  6KB  |  200 lines
  1. \ UTILS.SEQ     Some basic utilities
  2.  
  3.  
  4. : ?             ( adr -- )
  5.                 @ .   ;
  6.  
  7. : YCOUNT        ( a1 --- a2 n1 )
  8.                 DUP 1+ SWAP YC@ ;
  9.  
  10. : ?ENOUGH       ( n -- )
  11.                 DEPTH 1- > ABORT" Not enough Parameters" ;
  12.  
  13. : BS'S          ( n1 --- )
  14.                 0 MAX 80 MIN 0 ?DO 8 EMIT -2 #OUT +! LOOP ;
  15.  
  16. : .FREE         ( -- )
  17.                 ." Free Bytes:"
  18.                  ."  CODE = "       SP@       HERE - (U.) TYPE
  19.                 ." , LIST = " #LISTSEGS XHERE DROP XSEG @ - - 16 *D 1 D.R
  20.                 ." , HEAD = " #HEADSEGS 16 * YHERE - (U.) TYPE ;
  21.  
  22. : @REL>ABS      ( A1 --- A2 )         \ CONVERT CONTENTS OF A1
  23.                 DUP 1+ @ SWAP 3 + + ;     \ FROM RELATIVE TO ABSOLUTE
  24.  
  25. : DRIVE?        ( -- )   0 25 BDOS ASCII A + EMIT ." : "  ;
  26.  
  27.                 \ These are needed by later utilities
  28.  
  29. DEFER CCR       ' CR IS CCR             \ Carraige Carraige return?
  30.  
  31. DEFER .DEFSRC   ' NOOP IS .DEFSRC       \ Nothing for now, may be set
  32.                                         \ to display the source for the
  33.                                         \ current definition.
  34.  
  35. VARIABLE DEFCFA                         \ Holds the CFA of the current word.
  36. VARIABLE PFASAV                         \ Current offset into definition.
  37.  
  38. 2VARIABLE CTIME         GETTIME CTIME 2!
  39. 2VARIABLE CDATE         GETDATE CDATE 2!
  40.  
  41. : LARGEST       ( addr n -- addr' val )
  42.                 OVER 0 SWAP ROT 0
  43.                 DO      2DUP @ U<
  44.                         IF      -ROT 2DROP    DUP @ OVER
  45.                         THEN    2+
  46.                 LOOP    DROP   ;
  47.  
  48. \ : LABEL   PRECODE CREATE ASSEMBLER   ;
  49.  
  50. : DOES?         ( IP -- IP' F )  \ IP IS ACTUALLY CFA, IP' IS PFA
  51.                 DUP >BODY SWAP @REL>ABS @REL>ABS
  52.                 ['] FORTH      @REL>ABS @REL>ABS = ;
  53.  
  54. ' HEX @REL>ABS CONSTANT 'DOCOL
  55.  
  56. : >.ID          ( A1 --- )
  57.                 DUP 200 U< IF DROP EXIT THEN
  58.                 128 0
  59.                 DO      DUP @REL>ABS 'DOCOL =
  60.                         IF  LEAVE ELSE 1- THEN
  61.                 LOOP    >NAME .ID ;
  62.  
  63. VARIABLE FUDGE   65  FUDGE !            \  65 =  8Mhz AT Clone
  64.                                         \ 100 = 10Mhz AT Clone
  65. : MS   ( n -- )
  66.    0 ?DO   FUDGE @ 0 ?DO PAUSE LOOP  LOOP  ;
  67.  
  68. HEX
  69. : setfudge      ( --- )
  70.                 ( DEFERS INITSTUFF )
  71.                 SEQINIT                 \ Should use above line. but DEFERS
  72.                                         \ is defined later.
  73.                 F000 FFFE c@l 00FC =         \ 00FC = PCAT
  74.                 if 41 else 0F then fudge ! ; \ 00FF = PC
  75.                                              \ 00FE = XT
  76. ' SETFUDGE IS INITSTUFF                      \ 00FD = PCjr
  77.                                              \ 002D = Compaq PC
  78.                                              \ 009A = Compaq XT
  79. DECIMAL
  80.  
  81. : U<=   ( u1 u2 -- f )   U> NOT   ;
  82. : U>=   ( u1 u2 -- f )   U< NOT   ;
  83. : <=    ( n1 n2 -- f )   > NOT    ;
  84. : >=    ( n1 n2 -- f )   < NOT    ;
  85. : 0>=   ( n1 n2 -- f )   0< NOT   ;
  86. : 0<=   ( n1 n2 -- f )   0> NOT   ;
  87.  
  88. VARIABLE #TIMES   ( # times already performed )   1 #TIMES !
  89.  
  90. : TIMES   ( n -- )
  91.    1 #TIMES +!  #TIMES @
  92.    < IF  1 #TIMES !  ELSE  >IN OFF  THEN   ;
  93.  
  94. : MANY   ( -- )
  95.    KEY? NOT IF   >IN OFF   THEN   ;
  96.  
  97.  
  98.  
  99. : AT            ( col row -- )  ( 0 0 is upper left )
  100.                 DOES>  >R 2DUP R> PERFORM  #LINE !  #OUT ! ; AT
  101.  
  102. ' 2DROP IS AT
  103.  
  104. : DARK          ( -- )
  105.                 DOES>  PERFORM   #LINE OFF  #OUT OFF   ; DARK
  106.  
  107. ' NOOP IS DARK
  108.  
  109. : ?DARK         ( -- )
  110.                 KEY? 0= IF DARK CR THEN ;
  111.  
  112. DEFER -LINE
  113.  
  114. VARIABLE #PAGE
  115.  
  116. : PAGE   ( -- )
  117.    DOES> PERFORM   1 #PAGE +!   #LINE OFF   #OUT OFF   ; PAGE
  118.  
  119. : FORM-FEED   ( -- )   CONTROL M EMIT   CONTROL L EMIT  ;
  120.  
  121. ' FORM-FEED IS PAGE
  122.  
  123. : ?PAGE         ( --- )         \ PAGE IF LINE CNT NOT ZERO
  124.                 #LINE @
  125.                 IF      PAGE
  126.                 THEN    ;
  127.  
  128. : ALIAS         ( A1 | alias_NAME --- ) \ creates alias_NAME pointing
  129.                 >R CREATE -3 ALLOT YHERE 2-        \ A1=CFA OF REAL NAME
  130.                 R> >NAME YCOUNT 31 AND + Y@
  131.                 SWAP Y! ;
  132.  
  133.  
  134. VARIABLE NLEN
  135.  
  136. : >NAME.ID      ( CFA --- )
  137.                 >NAME DUP YC@ 31 AND DUP ?LINE NLEN ! .ID ;
  138.  
  139. DEFER (SEE)
  140.  
  141. DEFER INSTALLSTUFF      ' NOOP IS INSTALLSTUFF
  142. DEFER UNINSTALLSTUFF    ' NOOP IS UNINSTALLSTUFF
  143.  
  144. DEFER >ATTRIB1          ' NOOP IS >ATTRIB1
  145. DEFER >ATTRIB2          ' NOOP IS >ATTRIB2
  146. DEFER >ATTRIB3          ' NOOP IS >ATTRIB3
  147. DEFER >ATTRIB4          ' NOOP IS >ATTRIB4
  148. DEFER >NORM             ' NOOP IS >NORM
  149.  
  150. DECIMAL
  151.  
  152. VARIABLE RESTBASE       10 RESTBASE !
  153. VARIABLE RESTCAPS       RESTCAPS ON
  154. VARIABLE RESTTABS       8 RESTTABS !
  155. VARIABLE RESTLMRG       RESTLMRG OFF
  156. VARIABLE RESTRMRG       70 RESTRMRG !
  157. VARIABLE RESTSTAT       RESTSTAT OFF
  158. VARIABLE STATV          STATV OFF
  159.  
  160. : SAVESTATE     ( --- )
  161.                 BASE @ RESTBASE !
  162.                 CAPS @ RESTCAPS !
  163.                 LMARGIN @ RESTLMRG !
  164.                 RMARGIN @ RESTRMRG !
  165.                 TABSIZE @ RESTTABS !
  166.                 STATV   @ RESTSTAT ! ;
  167.  
  168. : RESTORESTATE  ( --- )
  169.                 RESTSTAT @ STATV !
  170.                 RESTBASE @ BASE !
  171.                 RESTCAPS @ CAPS !
  172.                 RESTLMRG @ LMARGIN !
  173.                 RESTRMRG @ RMARGIN !
  174.                 RESTTABS @ TABSIZE ! ;
  175.  
  176. : DEFAULTSTATE  ( --- )
  177.                 RESTSTAT ON
  178.                 10 RESTBASE !
  179.                 RESTCAPS ON
  180.                 8 RESTTABS !
  181.                 RESTLMRG OFF
  182.                 70 RESTRMRG !
  183.                 RESTORESTATE ;
  184.  
  185. : ?DOSTOP       ( F1 --- )
  186.                 IF      RESTORESTATE
  187.                         TRUE ABORT" Stopped"
  188.                 THEN    ;
  189.  
  190. : ?KEYPAUSE     ( --- )         \ Pause if key pressed
  191.                 KEY?
  192.                 IF      KEY 27 = ?DOSTOP
  193.                         KEY 27 = ?DOSTOP
  194.                 THEN    ;
  195.  
  196. : $>TIB         ( a1 --- )
  197.                 COUNT >R TIB R@ CMOVE R@ SPAN ! R> #TIB ! >IN OFF  ;
  198.  
  199.  
  200.